home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 015 / softad.arc / WIDTHS.PAS < prev   
Pascal/Delphi Source File  |  1987-01-07  |  15KB  |  438 lines
  1. {$G2048,P512,D-}
  2. program    widths;
  3. {-----------------------------------------------------------------------}
  4. {                                                                       }
  5. {    Program to Extract Width Table from HP Font Files                  }
  6. {                                                                       }
  7. {          widths   SOURCE  DESTINATION                                 }
  8. {                   (using DOS redirection facilities)                  }
  9. {                                                                       }
  10. {-----------------------------------------------------------------------}
  11.  
  12. label
  13.    QUIT;
  14.  
  15. type
  16.    Str64 = string[64] ;
  17.  
  18.  
  19. {---------------  Font Descriptor  -------------------------------------}
  20.  
  21.    FontMap = record
  22.          {+ 0}   Res0:       integer;
  23.          {+ 2}   Res1:       byte;
  24.          {+ 3}   FontType:   byte;
  25.          {+ 4}   Res2:       integer;
  26.          {+ 6}   Baseline:   integer;
  27.          {+ 8}   CellWidth:  integer;
  28.          {+10}   CellHeight: integer;
  29.          {+12}   Orientation: byte;
  30.          {+13}   FixedProp:  byte;
  31.          {+14}   SymbolSet:  integer;
  32.          {+16}   Pitch:      integer;
  33.          {+18}   Height:     integer;
  34.          {+20}   Res3:       integer;
  35.          {+22}   Res4:       byte;
  36.          {+23}   Style:      byte;
  37.          {+24}   StrokeWeight: byte;
  38.          {+25}   Typeface:   byte;
  39.               end;
  40.  
  41. {---------------  Character Descriptor  --------------------------------}
  42.    CharMap = record
  43.          {+ 0}   Res0:       integer;
  44.          {+ 2}   Res1:       integer;
  45.          {+ 4}   Orientation: char;
  46.          {+ 5}   Res2:       byte;
  47.          {+ 6}   LeftOffset: integer;
  48.          {+ 8}   TopOffset:  integer;
  49.          {+10}   CharWidth:  integer;
  50.          {+12}   CharHeight: integer;
  51.          {+14}   DeltaX:     integer;
  52.               end;
  53.  
  54.    HpFont = record
  55.               case Boolean of
  56.                  True:  (Tab: array[0..25] of Char);
  57.                  False: (Def: FontMap);
  58.  
  59.               end;
  60.  
  61.    HpChar = record
  62.               case Boolean of
  63.                  True:  (Tab: array[0..15] of Char);
  64.                  False: (Def: CharMap);
  65.               end;
  66.  
  67. Var
  68.  
  69.    CC, i, j, k :  integer;
  70.    Rpitch, Rsize : real;
  71.    Str2        :  string[2];
  72.    FontDesc    :  HpFont;
  73.    CharDesc    :  HpChar;
  74.    Wtab        :  array[32..255] of Byte;
  75.    Nextc       :  char;
  76.    Char1, Char2, Char3 : char;
  77.    NumStr      :  string[5];
  78.    Skip        :  integer;
  79.    CharCode    :  integer;
  80.    CharCount   :  integer;
  81.    MemUsed     :  real;
  82.  
  83. const
  84.    OrMap :  array[0..1] of string[10] = ('Portrait', 'Landscape');
  85.    SpMap :  array[0..1] of string[12] = ('Fixed', 'Proportional');
  86.    StMap :  array[0..1] of string[7] = ('Upright', 'Italic');
  87.    TyMap :  array[0..10] of string[15] = ('Line Printer',
  88.                                             'Pica',
  89.                                             'Elite',
  90.                                             'Courier',
  91.                                             'Helv',
  92.                                             'TmsRmn',
  93.                                             'Gothic',
  94.                                             'Script',
  95.                                             'Prestige',
  96.                                             'Caslon',
  97.                                             'Orator');
  98.    SwMap :  array[0..15] of string[12] = ('Normal','Normal+','Bold-','Bold',
  99.                                           'Bold+','Bold++','HiBold-','HiBold',
  100.                                           'Normal','Normal-','Light-','Light',
  101.                                           'Light+','Light++','LoLight-','LoLight');
  102.    SwiMap:  array[0..15] of integer = (0,1,2,3,4,5,6,7,0,-1,-2,-3,-4,-5,-6,-7);
  103.    FtMap :  array[0..1] of string[5] = ('7-Bit', '8-Bit');
  104.    FtSet :  array[0..1] of integer = (128, 256);
  105.    TrMap :  array[128..175] of integer = (180, 207, 197, 192,
  106.                                           204, 200, 212, 181,
  107.                                           193, 205, 201, 221,
  108.                                           209, 217, 216, 208,
  109.                                           220, 215, 211, 194,
  110.                                           206, 202, 195, 203,
  111.                                           239, 218, 219, 191,
  112.                                           187, 188,  80, 190,
  113.                                           196, 213, 198, 199,
  114.                                           183, 182, 249, 250,
  115.                                           185, 169, 170, 248,
  116.                                           247, 184, 251, 253);
  117.  
  118. function GetTyMap(arg:byte): Str64 ;
  119. var
  120.   TyStr : Str64;
  121. begin
  122.    TyStr := '*** not known';
  123.    if arg < 11
  124.       then TyStr := 'HP ' + TyMap[arg]
  125.       else case arg of
  126.               17: TyStr := 'BitStream ZapfHumanist' ;
  127.               18: TyStr := 'BitStream ItcGaramond' ;
  128.               19: TyStr := 'BitStream CooperBlack' ;
  129.               20: TyStr := 'BitStream CoronetBold' ;
  130.               21: TyStr := 'BitStream Broadway' ;
  131.               22: TyStr := 'BitStream BodiniBlack' ;
  132.               23: TyStr := 'BitStream CenturySchool' ;
  133.               24: TyStr := 'BitStream UniversityRoman' ;
  134.              106: TyStr := 'Softcraft RomanFixWidth' ;
  135.              112: TyStr := 'Softcraft SansSerif' ;
  136.              113: TyStr := 'Softcraft SansCompressed' ;
  137.              117: TyStr := 'Softcraft Classic' ;
  138.              118: TyStr := 'Softcraft Roman' ;
  139.              132: TyStr := 'Softcraft Script' ;
  140.              133: TyStr := 'Softcraft UnslantedItalic' ;
  141.              137: TyStr := 'Softcraft Formal' ;
  142.              138: TyStr := 'Softcraft Nouveau' ;
  143.              139: TyStr := 'Softcraft Modern' ;
  144.              140: TyStr := 'Softcraft Greek' ;
  145.              142: TyStr := 'Softcraft Hebrew' ;
  146.              143: TyStr := 'Softcraft Cyrillic' ;
  147.              149: TyStr := 'Softcraft Tall' ;
  148.              151: TyStr := 'Softcraft Twist' ;
  149.              152: TyStr := 'Softcraft OldEnglish' ;
  150.              153: TyStr := 'Softcraft Calligrapher' ;
  151.              154: TyStr := 'Softcraft Shadow' ;
  152.              155: TyStr := 'Softcraft Computer' ;
  153.              156: TyStr := 'Softcraft ClassicSymbols' ;
  154.              157: TyStr := 'Softcraft MathSymbols' ;
  155.              158: TyStr := 'Softcraft Accents' ;
  156.              else ;
  157.            end ;
  158.    GetTyMap := TyStr;
  159. end;
  160.  
  161. function GetSymbolSet(arg:integer): Str64 ;
  162. var
  163.   SyStr : Str64;
  164. begin
  165.    SyStr := '*** not known' ;
  166.       case arg of
  167.          277: SyStr := '8U ==> Roman-8' ;
  168.          267: SyStr := '8K ==> Roman-8' ;
  169.          269: SyStr := '8M ==> Roman-8' ;
  170.           21: SyStr := '0U ==> USASCII' ;
  171.            2: SyStr := '0B ==> Line Draw' ;
  172.            1: SyStr := '0A ==> Math Symbols' ;
  173.           53: SyStr := '1U ==> US Legal' ;
  174.            5: SyStr := '0E ==> Roman Extension' ;
  175.            4: SyStr := '0D ==> ISO Denmark/Norway' ;
  176.           37: SyStr := '1E ==> ISO United Kingdom' ;
  177.            6: SyStr := '0F ==> ISO France' ;
  178.            7: SyStr := '0G ==> ISO German' ;
  179.            9: SyStr := '0I ==> ISO Italy' ;
  180.           19: SyStr := '0S ==> ISO Sweden/Finland' ;
  181.           51: SyStr := '1S ==> ISO Spain' ;
  182.           else ;
  183.       end;
  184.    GetSymbolSet := SyStr;
  185. end;
  186.  
  187. function GetStrVal(arg:integer): Str64 ;
  188. var
  189.   SyStr : Str64;
  190. begin
  191.   SyStr := '';
  192.   if arg > 0
  193.      then Str(arg, Systr);
  194.   GetStrVal := SyStr;
  195. end;
  196.  
  197.  
  198.  
  199. begin
  200.  
  201.    WriteLn(Con, 'WIDTHS v1.01');
  202.    WriteLn(Con, 'Denis DeLaRoca, 1987');
  203.    WriteLn('=================================================================');
  204.    WriteLn('');
  205.  
  206. {------  Make Sure File starts with Font Desc: "^[)s"  ----------------}
  207.  
  208.    read(Char1, Char2, Char3);
  209.    if (Char1 <> #$1b) or (Char2 <> ')') or (Char3 <> 's')
  210.       then begin
  211.               writeln('*** Missing Font Descriptor');
  212.               halt(1);
  213.            end;
  214.  
  215. {------  Extract Length of Descriptor + Data   ------------------------}
  216.  
  217.    NumStr := '';
  218.    read(Nextc);
  219.    while nextc <> 'W' do
  220.    begin
  221.       NumStr := NumStr + nextc;
  222.       read(nextc);
  223.    end;
  224.    Val(NumStr, Skip, CC);
  225.    if CC <> 0
  226.       then begin
  227.               writeln('*** Bad Font Descriptor Length');
  228.               halt(2);
  229.            end;
  230.  
  231. {------  Read Font Descriptor Header and Output Some Parms   ----------}
  232.  
  233.    for i := 0 to 25
  234.       do read(FontDesc.Tab[i]);
  235.    with FontDesc, Def do
  236.    begin
  237.       CellWidth := Swap(CellWidth);
  238.       CellHeight := Swap(CellHeight);
  239.       Pitch := Swap(Pitch);
  240.       BaseLine := Swap(BaseLine);
  241.       SymbolSet := Swap(SymbolSet);
  242.       Height := Swap(Height);
  243.       WriteLn('Symbol Set  = ', SymbolSet, ' ==> ', GetSymbolSet(SymbolSet));
  244.       WriteLn('Font Type   = ', FtMap[FontType]);
  245.       WriteLn('Typeface    = ', Typeface, ' ==> ', GetTyMap(Typeface)) ;
  246.       WriteLn('Orientation = ', OrMap[Orientation]);
  247.       WriteLn('Style       = ', StMap[Style]);
  248.       WriteLn('Weight      = ', SwiMap[StrokeWeight], ' ==> ', SwMap[StrokeWeight]);
  249.       WriteLn('Spacing     = ', SpMap[FixedProp]);
  250.       WriteLn('Cell Width  = ', CellWidth, ' dots');
  251.       WriteLn('Cell Height = ', CellHeight, ' dots');
  252.       WriteLn('BaseLine    = ', BaseLine, ' dots from top');
  253.       Write  ('Default HMI = ', Round(Pitch/4), ' dots');
  254.       WriteLn(',  or ', Round(1200/Pitch), ' pitch');
  255.       Write  ('Font Height = ', Height div 4, ' dots');
  256.       WriteLn(',  ', Round((Height*3)/50), ' point-size');
  257.                     {Round((Height*72)/1200)}
  258.       Rpitch := (1200.0 / Pitch) + 0.005;
  259.       Rsize :=  ((Height * 72.0) / 1200.0) + 0.005;
  260.       WriteLn('Real Pitch  = ', Rpitch:5:2, ' cpi');
  261.       WriteLn('Real Size   = ', Rsize:5:2, ' pts');
  262.       Write  ('Font Select = ');
  263.       Write('^[&I', GetStrVal(Orientation), 'O');
  264.       Str2 := GetSymbolSet(SymbolSet);
  265.       Write('^[(', Str2);
  266.       Write('^[(s', GetStrVal(FixedProp), 'p');
  267.       if FixedProp = 0
  268.          then Write(Round(1200/Pitch), 'h');
  269.       Write(Round((Height*3)/50), 'v');
  270.            {Round((Height*72)/1200)}
  271.       Write(GetStrVal(Style), 's');
  272.       Write(GetStrVal(SwiMap[StrokeWeight]), 'b');
  273.       WriteLn(GetStrVal(Typeface), 'T');
  274.    end;
  275.  
  276.  
  277. {------  Initialize Widths Table   ------------------------------------}
  278.  
  279.    for i := 32 to 255
  280.       do Wtab[i] := Round(FontDesc.Def.Pitch/4);
  281.    for i := 128 to 160
  282.       do Wtab[i] := 0;
  283.  
  284. {------  Now Skip Rest of Font Descriptor Data  ------------------------}
  285.  
  286.    Skip := Skip - 26;
  287.    for i := 1 to skip
  288.       do Read(Nextc);
  289.  
  290. {------  Now Start Main Loop, Extracting Char Widths  -----------------}
  291.  
  292.    CharCount := 0;
  293.    repeat
  294.       repeat
  295.          read(Char1);
  296.       until (Char1 = #$1b);
  297.       read(Char2, Char3);
  298.    until (Char2 = '*') and (Char3 = 'c');
  299.  
  300. {------  Validate Char Code Descriptor --------------------------------}
  301.  
  302.    while ((not EOF) and (Char1 <> #$00)) do
  303.    begin
  304.       if (Char1 <> #$1b) or (Char2 <> '*') or (Char3 <> 'c')
  305.          then begin
  306.                  writeln('*** Bad Char Code Desc');
  307.                  halt(3);
  308.               end;
  309.  
  310. {------  Count Number of Character Descriptors in Font -----------------}
  311.  
  312.       CharCount := CharCount + 1;
  313.  
  314. {------  Extract Char Code Value  --------------------------------------}
  315.  
  316.       NumStr := '';
  317.       Read(Nextc);
  318.       while nextc <> 'E' do
  319.       begin
  320.          NumStr := NumStr + Nextc;
  321.          Read(Nextc);
  322.       end;
  323.       Val(NumStr, CharCode, CC);
  324.  
  325. {------  Validate Char Font Descriptor  -------------------------------}
  326.  
  327.       Read(Char1,Char2, Char3);
  328.       if (Char1 <> #$1b) or (Char2 <> '(') or (Char3 <> 's')
  329.          then begin
  330.                  writeln('*** Bad Char Descriptor');
  331.                  halt(4);
  332.                end;
  333.  
  334. {------  Extract Length of Descriptor + Data  -------------------------}
  335.  
  336.       NumStr := '';
  337.       Read(Nextc);
  338.       while nextc <> 'W' do
  339.       begin
  340.          NumStr := NumStr + Nextc;
  341.          Read(Nextc);
  342.       end;
  343.       Val(NumStr, Skip, CC);
  344.  
  345. {------  Read Char Font Descriptor  ------------------------------------}
  346.  
  347.       for i := 0 to 15
  348.          do Read(CharDesc.Tab[i]);
  349.       with CharDesc, Def do
  350.       begin
  351.          LeftOffset := Swap(LeftOffset);
  352.          TopOffset  := Swap(TopOffset);
  353.          CharWidth  := Swap(CharWidth);
  354.          CharHeight := Swap(CharHeight);
  355.          Deltax     := Swap(Deltax);
  356.          Wtab[CharCode] := Deltax div 4;     {--- Char Width ----------}
  357.       end;
  358.  
  359. {------  Skip Char Font Data  ------------------------------------------}
  360.  
  361.       Skip := Skip - 16;
  362.       for i := 1 to Skip
  363.          do Read(Nextc);
  364.  
  365. {------  Try to Fetch Next Char Code Descriptor  ----------------------}
  366.  
  367.       Read(Char1, Char2, Char3);
  368.    end;
  369.  
  370.  
  371. {------  Output: # Char Descriptors + Font Memory Utilization ---------}
  372.  
  373.    with FontDesc, Def do
  374.    begin
  375.       WriteLn('Font Chars  = ', CharCount, ' chars defined in font');
  376. {     i := (((CellWidth - 1) div 8) + 1);
  377.       j := (((CellHeight - 1) div 8) + 1);
  378.       MemUsed := FtSet[FontType]*64*(((i*j-1)/64)+1);
  379.       WriteLn('Memory Use  = ', MemUsed:6:0, ' bytes of LaserJet+ memory'); }
  380.    end;
  381.  
  382. {------  If Font is fixed-spaced then we are done  --------------------}
  383.  
  384.    if FontDesc.Def.FixedProp = 0
  385.       then goto QUIT;
  386.  
  387. {------  Now Output Char Widths Table (MS Word Format)  ---------------}
  388.  
  389.    WriteLn('');
  390.    WriteLn('{Wn');
  391.    if (FontDesc.Def.FontType = 0)
  392.       then begin
  393.               i := 127;
  394.               k := 11;
  395.            end
  396.       else begin
  397.               i := 255;
  398.               k := 27;
  399.            end;
  400.    WriteLn('FontSize:',
  401.       Round((FontDesc.Def.Height*3)/25),' chFirst:32 chLast:',i);
  402.    for i := 0 to k do
  403.       begin
  404.          for j := 0 to 7 do
  405.             write(' ',32+i*8+j, ':', wtab[32+i*8+j], ' ');
  406.          writeln('');
  407.       end;
  408.    WriteLn('');
  409.    WriteLn('}W');
  410.    WriteLn('');
  411.    if (FontDesc.Def.FontType = 0)
  412.       then goto QUIT;
  413.  
  414. {------  Correct Widths of Char Range 128 to 175  ---------------------}
  415.  
  416.    for i := 128 to 175 do
  417.       wtab[i] := wtab[TrMap[i]];
  418.  
  419. {------  Now Output Char Widths Table (MS Word Format)  ---------------}
  420.  
  421.    WriteLn('');
  422.    WriteLn('{Wn');
  423.    WriteLn('FontSize:',
  424.       Round((FontDesc.Def.Height*3)/25),' chFirst:32 chLast:175');
  425.    for i := 0 to 17 do
  426.       begin
  427.          for j := 0 to 7 do
  428.             write(' ',32+i*8+j, ':', wtab[32+i*8+j], ' ');
  429.          writeln('');
  430.       end;
  431.    WriteLn('');
  432.    WriteLn('}W');
  433.    WriteLn('');
  434.  
  435. QUIT:
  436.  
  437. end.
  438.